
(define-structure woof-structure type-name values value-names value-count)

(define-macro (define-woof-structure type-name #!key (is-a '()) #!rest field-names)
  (let* ((super-type-names (append (list type-name) is-a))

	 (num-fields (length field-names))

	 (make-func-name (string->symbol (string-append "make-"
							(symbol->string type-name))))

	 (pred-func-name (string->symbol (string-append (symbol->string type-name)
							"?" )))
	 (accessor-func-names (map (lambda (field-name)
				     (string->symbol (string-append 
						      (symbol->string type-name)
						      "-"
						      (symbol->string field-name))))
				   field-names))
	 
	 (mutator-func-names (map (lambda (field-name)
				    (string->symbol (string-append 
						     (symbol->string type-name)
						     "-"
						     (symbol->string field-name)
						     "-set!"
						     )))

				  field-names)))
    ;; Define creation, accessing and mutating functions for new type
    `(begin
       (define (,make-func-name ,@field-names)
	 (make-woof-structure ',type-name
			      (list->vector (list ,@field-names))
			      ',field-names
			      ,num-fields
			      ))
       (define (,pred-func-name obj)
	 (includes? (woof-structure-type-name obj) ',super-type-names))
       
       ,@(map (lambda (field-name func-name)
		(let ((pos (- num-fields (length (memq field-name field-names)))))
		`(define (,func-name obj)
		   (vector-ref (woof-structure-values obj) ,pos))))
	      field-names accessor-func-names)
       
       ,@(map (lambda (field-name func-name)
		(let ((pos (- num-fields (length (memq field-name field-names)))))
		`(define (,func-name obj val)
		   (vector-set! (woof-structure-values obj) ,pos val))))
	      field-names mutator-func-names)
       
       )))


